How to classify this data

Before you start working with data for a machine learning project, it is vital to understand what the data is, and what we want to achieve. Without it, we have no basis from which to make our decisions about what data is relevant as we clean and prepare our data. - (Devlin, 2016)

The typical way to classify this data, is to determine approximate age based on the ring value, according to the UCI page for this dataset, the rings roughly suggest age such that y = r + 2.5, where y is number of years and r is number of rings. The simplest approach is to attempt to guess the correct number of rings for a test instance based on other attributes.

Getting the data

Having downloaded the data from the UCI repository (Hussain, no date, Brownlee (2016a)) we need convert the data into a table and check it’s usable.

abalone_data = data.frame(read.table("../assets/data/abalone.data", sep = ","))
abalone_attr_names = c("sex", "length", "diameter", "height", "weight.whole", "weight.shucked", "weight.viscera", "weight.shell", "rings")
colnames(abalone_data) = abalone_attr_names

#We need to check there are no missing values, as if any instances are incomlete we will need to remove
missing_vals = sum(is.na(abalone_data))
print(c("Number of missing values:", missing_vals), quote = FALSE)

## [1] Number of missing values: 0

Here’s a glance at the dataset.

head(abalone_data)

##   sex length diameter height weight.whole weight.shucked weight.viscera
## 1   M  0.455    0.365  0.095       0.5140         0.2245         0.1010
## 2   M  0.350    0.265  0.090       0.2255         0.0995         0.0485
## 3   F  0.530    0.420  0.135       0.6770         0.2565         0.1415
## 4   M  0.440    0.365  0.125       0.5160         0.2155         0.1140
## 5   I  0.330    0.255  0.080       0.2050         0.0895         0.0395
## 6   I  0.425    0.300  0.095       0.3515         0.1410         0.0775
##   weight.shell rings
## 1        0.150    15
## 2        0.070     7
## 3        0.210     9
## 4        0.155    10
## 5        0.055     7
## 6        0.120     8

abalone_summary = summary(abalone_data)

grid.table(abalone_summary)

kable(abalone_summary)

The attributes explained

The Abalone is a type of shellfish and each attribute describes a characteristic of the animal. Not being an expert on this animal, I’ve had to research a little bit about the Abalone in order to get an idea of what these traits are. Knowing a bit more about these properties, should hopefully lead to a better understanding of the data. What follows is a list of definitions for each column.

sex

M (male), F (female), or I (infant). Presumably, an infant Abalone lacks a sex or it’s too hard to identify

length

Longest shell measurement, in millimetres

diameter

Perpendicular measurement to measured length, in millimetres

height

Height of abalone, including body, in millimetres

weight.whole

Weight of whole abalone, in grams

weight.shucked

Weight of meat alone, in grams

weight.viscera

Weight of guts and other non meat alone, in grams

weight.shell

weight of shell alone, after drying, in grams

rings

Number of rings in the shell, strongly correlated to age but with a delta

A little bit of basic data cleansing

The data was checked to see if there were any missing values but it’s also worth checking of some values are technically impossible and therefore belonging to incorrect entries that need to be removed; to do this, all values are iterated over to check for assignments of 0, indicating bad data (Jolly, 2017).

abalone_numeric_attr <- abalone_attr_names[which(abalone_attr_names!="sex")] 

for (abalone_attr in abalone_numeric_attr)
{
  bad_vals = abalone_data[abalone_data[abalone_attr] == 0, ]
  #col_data = unlist(abalone_data[abalone_attr])
  if (nrow(bad_vals) > 0)
  {
    print(abalone_attr)
    print(abalone_data[abalone_data[abalone_attr] == 0, ])
  }

}

## [1] "height"
##      sex length diameter height weight.whole weight.shucked weight.viscera
## 1258   I  0.430     0.34      0        0.428         0.2065         0.0860
## 3997   I  0.315     0.23      0        0.134         0.0575         0.0285
##      weight.shell rings
## 1258       0.1150     8
## 3997       0.3505     6

rm(bad_vals)

It appears that there are two height values that are incorrect, so we should remove these instances from our dataset.

abalone_data$height[abalone_data$height==0] = NA
abalone_data = na.omit(abalone_data)

It’s also worth examining the weight data, to ensure that the total data is not less than the combined values to the other weight values.

abalone_data_bad_weight = abalone_data[(abalone_data$weight.whole - (abalone_data$weight.shucked + abalone_data$weight.viscera + abalone_data$weight.shell)) < 0,]

head(abalone_data_bad_weight)

##    sex length diameter height weight.whole weight.shucked weight.viscera
## 43   I  0.240    0.175  0.045       0.0700         0.0315         0.0235
## 44   I  0.205    0.150  0.055       0.0420         0.0255         0.0150
## 45   I  0.210    0.150  0.050       0.0420         0.0175         0.0125
## 46   I  0.390    0.295  0.095       0.2030         0.0875         0.0450
## 47   M  0.470    0.370  0.120       0.5795         0.2930         0.2270
## 61   M  0.450    0.345  0.105       0.4115         0.1800         0.1125
##    weight.shell rings
## 43        0.020     5
## 44        0.012     5
## 45        0.015     4
## 46        0.075     7
## 47        0.140     9
## 61        0.135     7

print(paste(c("Number of instances where total weight is less than constiuent weights:", nrow(abalone_data_bad_weight)), sep = ""), quote = FALSE)

## [1] Number of instances where total weight is less than constiuent weights:
## [2] 154

It would appear that the data isn’t completely sanitized, with this sort of erroneous data entry needing to be handled as well. The simplest option is to rule out these instances as well.

abalone_data <- abalone_data[!(abalone_data$weight.whole - (abalone_data$weight.shucked + abalone_data$weight.viscera + abalone_data$weight.shell)) < 0,]

A graphical look at the attributes

Below is an examination of each attribute to see if there are any obvious outliers that might need to be removed

#boxplot(scale(abalone_data), main="Looking at the data graphically", xlab="Abalone Attributes", ylab="Values") 

plot(abalone_data$sex)

for (abalone_attr in abalone_numeric_attr)
{
  #print(abalone_attr)
  col_data = unlist(abalone_data[abalone_attr])
  #print(col_data)
  plot(density(col_data), xlab=abalone_attr, main=paste(c("Density of ", abalone_attr), collapse = ''))
}

rm(abalone_attr)
rm(col_data)

In order to work out which attributes should be considered to have valid outliers, I’ve gone with a heuristic approach, choosing to look at the distance between the uppermost outliers for each attribute and it’s nearest neighbour.

#Create a list to populate with our tail neighbour distances
tail_deltas <- c()

abalone_data_no_sex = abalone_data[, -1]

for (attrib in abalone_data_no_sex) {
 #get the last two values
 data_tails <- tail(sort(attrib),2)
 #push the delta on to our list 
 tail_deltas <- c(tail_deltas, diff(data_tails))
}

#grab out attribute keys to include in our new table/frame
attributes <- names(abalone_data_no_sex)

#make a new dataframe from 
dataframe <- data.frame(attributes = attributes, tail_neighbour_d=tail_deltas)

#get the order for the nearest neighbour starting with the greatest distance and descending
neighbour_order <- order(dataframe$tail_neighbour_d, decreasing=TRUE)

#now apply the order to the frame
sorted_attributes_by_neighbour_d <- dataframe[ neighbour_order, ]
sorted_attributes_by_neighbour_d

##       attributes tail_neighbour_d
## 8          rings           2.0000
## 3         height           0.6150
## 5 weight.shucked           0.1395
## 6 weight.viscera           0.1185
## 7   weight.shell           0.1080
## 4   weight.whole           0.0460
## 2       diameter           0.0200
## 1         length           0.0150

While rings is at the top of the leader-board regarding the delta, it’s important to take into account that this data isn’t scaled; it’s very likely that this outlier is the results of a particularly lucky Abalone that managed to live longer than the rest of the long tail through some luck. Given that the other values are meant to be in grams and millimetres, it’s reasonable to compare values like for like in this instance. As such the weight deltas as comparable and can be excluded from outlier cleansing, with the same applying to diameter and length; height seems to be anomalous though and will need further attention.

It’s easier to see on a box-plot that one value is way out far from any neighbours, with its nearest neighbour also having no nearby neighbour; we could probably benefit just from removing the two farthest outliers.

boxplot(abalone_data$height)

abalone_data_cleansed <- abalone_data[ abalone_data$height < .5, ]
boxplot(abalone_data_cleansed$height)

  qplot(x = length, 
      y = rings, 
      data = abalone_data_cleansed,
      alpha = I(0.2), # alpha to help convery density
      geom = "jitter") + # jitter so points don't stack so much
  geom_smooth(method = lm)

  qplot(x = diameter, 
      y = rings, 
      data = abalone_data_cleansed,
      alpha = I(0.2), # alpha to help convery density
      geom = "jitter") + # jitter so points don't stack so much
  geom_smooth(method = lm)

  qplot(x = height, 
      y = rings, 
      data = abalone_data_cleansed,
      alpha = I(0.2), # alpha to help convery density
      geom = "jitter") + # jitter so points don't stack so much
  geom_smooth(method = lm)

  qplot(x = weight.whole, 
      y = rings, 
      data = abalone_data_cleansed,
      alpha = I(0.2), # alpha to help convery density
      geom = "jitter") + # jitter so points don't stack so much
  geom_smooth(method = lm)

  qplot(x = weight.shucked, 
      y = rings, 
      data = abalone_data_cleansed,
      alpha = I(0.2), # alpha to help convery density
      geom = "jitter") + # jitter so points don't stack so much
  geom_smooth(method = lm)

  qplot(x = weight.viscera, 
      y = rings, 
      data = abalone_data_cleansed,
      alpha = I(0.2), # alpha to help convery density
      geom = "jitter") + # jitter so points don't stack so much
  geom_smooth(method = lm)

  qplot(x = weight.shell, 
      y = rings, 
      data = abalone_data_cleansed,
      alpha = I(0.2), # alpha to help convery density
      geom = "jitter") + # jitter so points don't stack so much
  geom_smooth(method = lm)

Picking data attributes to select

With our cleansed data we can see that there is an evident correlation between all of these attributes and the number of rings but in particular those relating to physical size show the strongest relationship as the points best match the line of best fit; the weight values are distributed in such a way that there’s a little curve away from the line as you reach 0 on both axes and they also seem to diverge more from the line as the dimension values increase. Should any attributes be selected as ones to work with, discarding the others, it would be:

• length
• diameter
• height
• weight.whole

Given that the all attributes appear to display a fairly linear relationship to the ring count we can use r-squared, otherwise known as the Coefficient of Determination to verify how well the data matches the line of best fit (Frost, no date, Frost (no date)).

abalone.lm_length <- lm(data = abalone_data_cleansed, formula = rings ~ length)
abalone.lm_diameter <- lm(data = abalone_data_cleansed, formula = rings ~ diameter)
abalone.lm_height <- lm(data = abalone_data_cleansed, formula = rings ~ height)
abalone.lm_weight.whole <- lm(data = abalone_data_cleansed, formula = rings ~ weight.whole)
abalone.lm_weight.shucked <- lm(data = abalone_data_cleansed, formula = rings ~ weight.shucked)
abalone.lm_weight.viscera <- lm(data = abalone_data_cleansed, formula = rings ~ weight.viscera)
abalone.lm_weight.shell <- lm(data = abalone_data_cleansed, formula = rings ~ weight.shell)

abalone.r_squareds <- c(
  summary(abalone.lm_length)$adj.r.squared,
summary(abalone.lm_diameter)$adj.r.squared,
summary(abalone.lm_height)$adj.r.squared,
summary(abalone.lm_weight.whole)$adj.r.squared,
summary(abalone.lm_weight.shucked)$adj.r.squared,
summary(abalone.lm_weight.viscera)$adj.r.squared,
summary(abalone.lm_weight.shell)$adj.r.squared
)

abalone_numeric_attr_no_rings <- abalone_numeric_attr[which(abalone_numeric_attr!="rings")] 

#make a new dataframe from 
dataframe.rsquareds <- data.frame(attributes = abalone_numeric_attr_no_rings, r_squared=abalone.r_squareds)

#get the order for the nearest neighbour starting with the greatest distance and descending
rsquareds_order <- order(dataframe.rsquareds$r_squared, decreasing=TRUE)

#now apply the order to the frame
sorted_attributes_by_r_squared <- dataframe.rsquareds[ rsquareds_order, ]
sorted_attributes_by_r_squared

##       attributes r_squared
## 7   weight.shell 0.3855553
## 3         height 0.3604153
## 2       diameter 0.3155304
## 1         length 0.2950611
## 4   weight.whole 0.2806291
## 6 weight.viscera 0.2439019
## 5 weight.shucked 0.1681050

#abalone.lm_length

After looking at these results it may be wiser to consider using the shell weight alone if necessary; the r-squared value isn’t a perfect predictor of the fitness but perhaps in this case, it could make more sense to use a weight value that could fluctuate less in nature. Selection of the attributes relating to size appear to be validated.

# calculate correlation matrix
correlationMatrix <- cor(abalone_data_cleansed[,2:9])
# summarize the correlation matrix
print(correlationMatrix)

##                   length  diameter    height weight.whole weight.shucked
## length         1.0000000 0.9861689 0.8974579    0.9259423      0.9003873
## diameter       0.9861689 1.0000000 0.9040452    0.9260010      0.8952472
## height         0.8974579 0.9040452 1.0000000    0.8873269      0.8361649
## weight.whole   0.9259423 0.9260010 0.8873269    1.0000000      0.9709880
## weight.shucked 0.9003873 0.8952472 0.8361649    0.9709880      1.0000000
## weight.viscera 0.9034261 0.8997239 0.8656499    0.9670606      0.9323660
## weight.shell   0.8977314 0.9055333 0.8897232    0.9561399      0.8830020
## rings          0.5433567 0.5618726 0.6004786    0.5299133      0.4102585
##                weight.viscera weight.shell     rings
## length              0.9034261    0.8977314 0.5433567
## diameter            0.8997239    0.9055333 0.5618726
## height              0.8656499    0.8897232 0.6004786
## weight.whole        0.9670606    0.9561399 0.5299133
## weight.shucked      0.9323660    0.8830020 0.4102585
## weight.viscera      1.0000000    0.9070347 0.4940547
## weight.shell        0.9070347    1.0000000 0.6210541
## rings               0.4940547    0.6210541 1.0000000

# find attributes that are highly corrected (ideally >0.75)
highlyCorrelated <- findCorrelation(correlationMatrix, cutoff=0.5)

abalone.correlation <- data.frame(correlation=correlationMatrix[,8])
#get rid of rings, that's obviously going to be max correlation to itself!
abalone.correlation <- data.frame(attributes=rownames(abalone.correlation)[1:7], 'correlation to rings'=abalone.correlation[1:7, 0:1])

#get the order for correlations
correlation_order <- order(abalone.correlation$correlation, decreasing=TRUE)

#now apply the order to the frame
sorted_correlation_order <- abalone.correlation[ correlation_order, 1:2]
print(sorted_correlation_order)

##       attributes correlation.to.rings
## 7   weight.shell            0.6210541
## 3         height            0.6004786
## 2       diameter            0.5618726
## 1         length            0.5433567
## 4   weight.whole            0.5299133
## 6 weight.viscera            0.4940547
## 5 weight.shucked            0.4102585

Evaluating the holdout datasets

By looking at the dimensionality it’s possible to confirm that the new datasets are of the correct size

dim(holdout.training)

## [1] 2681    9

dim(holdout.testing)

## [1] 1338    9

Holdout set for age group factor dataset

As an addition, the dataset modified to have an age_group factor attribute instead of rings attribute of integers, will also be partitioned for use with the holdout method.

head(abalone_data_cleansed_age_groups)

##   sex length diameter height weight.whole weight.shucked weight.viscera
## 1   M  0.455    0.365  0.095       0.5140         0.2245         0.1010
## 2   M  0.350    0.265  0.090       0.2255         0.0995         0.0485
## 3   F  0.530    0.420  0.135       0.6770         0.2565         0.1415
## 4   M  0.440    0.365  0.125       0.5160         0.2155         0.1140
## 5   I  0.330    0.255  0.080       0.2050         0.0895         0.0395
## 6   I  0.425    0.300  0.095       0.3515         0.1410         0.0775
##   weight.shell age_group
## 1        0.150       old
## 2        0.070     young
## 3        0.210     young
## 4        0.155    middle
## 5        0.055     young
## 6        0.120     young

holdout_age_groups.train_indeces <- createDataPartition(y = abalone_data_cleansed_age_groups$weight.shell, p= 2/3, list = FALSE)
head(holdout_age_groups.train_indeces, n=20)

##       Resample1
##  [1,]         1
##  [2,]         2
##  [3,]         3
##  [4,]         4
##  [5,]         6
##  [6,]         8
##  [7,]         9
##  [8,]        12
##  [9,]        13
## [10,]        14
## [11,]        15
## [12,]        16
## [13,]        17
## [14,]        19
## [15,]        21
## [16,]        22
## [17,]        23
## [18,]        24
## [19,]        25
## [20,]        26

holdout_age_groups.training <- abalone_data_cleansed_age_groups[holdout.train_indeces,]

holdout_age_groups.testing <- abalone_data_cleansed_age_groups[-holdout.train_indeces,]

Repeated k-fold Cross-validation

Repeated k-fold cross-validation takes the technique yet another step further, by splitting the dataset into k folds, repeatedly such that different fragmentation occurs each time; that is to say that even though the number of divisions are the same, each repetition creates a different set of subsets. By doing so, this sort of shuffling further economically reuses the dataset for training purposes.

For the sake of evaluating this method more thoroughly, the dataset will be used with k-fold 3 times, using Fibonacci sequence numbers 8 & 13 for k and 5 & 8 for the number of iterations of cross-validation. For comparison, a standard k-folds of will also be used

cv.train_control_8 <- trainControl(method="cv", number=8)
cv.train_control_8_5 <- trainControl(method="repeatedcv", number=8, repeats = 5)
cv.train_control_13_5 <- trainControl(method="repeatedcv", number=13, repeats = 5)
cv.train_control_13_8 <- trainControl(method="repeatedcv", number=13, repeats = 8)

These training controls will be used later on in this study to train the various models for the task of classification but for now they are merely abstract instructions on how to chunk the data.

The J48 method

load("holdout.training.rda")
load("holdout.testing.rda")


dt.c4_5_j48_h <- J48(as.factor(rings)~., holdout.training) 
dt_sum.c4_5_j48_h <- summary(dt.c4_5_j48_h)
dt.c4_5_j48_h_party <- as.party(dt.c4_5_j48_h)

The J48 function is extremely quick with the dataset, training takes less than a second, which on it’s on is not necessarily worthy of note but certainly more interesting when compared to the speed of using the caret train method with a “J48” method argument value.

We can look at the complexity of the tree by looking at the dimensionality, where the length is effectively the tree size, width is the number of leaves, or terminal nodes and the depth is effectively the number of conditional branch layers.

length(dt.c4_5_j48_h_party)

## [1] 1534

width(dt.c4_5_j48_h_party)

## [1] 784

depth(dt.c4_5_j48_h_party)

## [1] 22

The complexity of this tree is sufficiently complex to render a graphical representation useless. In fact the tree is complex it’s time intensive as well as being of no value.

The caret train J48 argument

dt.c4_5_h2 <- train(as.factor(rings) ~., method="J48", holdout.training, tuneLength = 8)
dt_sum.c4_5_h2 <- summary(dt.c4_5_h2)
dt.c4_5_h2_finalModel <- dt.c4_5_h2$finalModel
dt_sum.c4_5_h2_final <- summary(dt.c4_5_h2_finalModel)

Whilst in comparisons to other forms of training and data-mining algorithms, under 5 minutes for a 4,000 by 9 dataset might seem okay, in comparison to the J48 function, there seems to be something at odds. The proof will be in the comparison of the two models with regard to accuracy on the test dataset.

Again, we can look at the complexity of the tree through dimensionality, length being total size, width being leaf nodes and depth being branch layer count.

#dt.c4_5_h2
#dt.c4_5_h2_finalModel <- dt.c4_5_h2$finalModel
#dt.c4_5_h2_finalModel
dt.c4_5_h2_finalModel_party <- as.party(dt.c4_5_h2_finalModel)
#dt.c4_5_h2_finalModel_party <- as.party(dt.c4_5_h2$finalModel)
length(dt.c4_5_h2_finalModel_party)

## [1] 89

width(dt.c4_5_h2_finalModel_party)

## [1] 45

depth(dt.c4_5_h2_finalModel_party)

## [1] 12

It would appear that the ‘final model’ we are looking at derived from the train function has already been pruned, making for a simpler decision tree; this tree is actually able to be represented graphically within a reasonable amount of time (under 10 seconds).

#plot(dt.c4_5_h2_finalModel)
plot(dt.c4_5_h2_finalModel_party)

Even though the tree is able to be rendered it’s not easy to get anything meaningful out of this. Perhaps the most pertinent point is that not only could the classification levels benefit from being simplified but using fewer dimensions for observation would also force a simpler set of conditional branching.

Comparing the two C4.5/J48 methods

Below follows the summaries from both methods, for examination:

dt_sum.c4_5_j48_h

## 
## === Summary ===
## 
## Correctly Classified Instances        2033               75.8299 %
## Incorrectly Classified Instances       648               24.1701 %
## Kappa statistic                          0.7279
## Mean absolute error                      0.0234
## Root mean squared error                  0.1081
## Relative absolute error                 35.265  %
## Root relative squared error             59.4069 %
## Total Number of Instances             2681     
## 
## === Confusion Matrix ===
## 
##    a   b   c   d   e   f   g   h   i   j   k   l   m   n   o   p   q   r   s   t   u   v   w   x   y   z  aa   <-- classified as
##    0   1   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   a = 2
##    0   5   2   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   b = 3
##    0   1  31   0   2   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   c = 4
##    0   1   4  57   7   4   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   d = 5
##    0   0   3   5 133   7   2   1   0   1   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   e = 6
##    0   0   1   3  12 203  12   5   5   2   0   1   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   f = 7
##    0   0   2   1   8  22 294  25  12   6   0   1   2   1   0   0   0   0   0   0   0   0   0   0   0   0   0 |   g = 8
##    0   0   0   3   4   6  21 363  13  21   2   2   0   0   0   1   0   0   0   0   0   0   0   0   0   0   0 |   h = 9
##    0   0   0   0   2   4  16  31 342  11   5   5   1   0   1   0   0   0   0   0   0   0   0   0   0   0   0 |   i = 10
##    0   0   0   0   3   7  14  13  18 260   5   2   1   1   1   1   0   0   0   0   0   1   0   0   0   0   0 |   j = 11
##    0   0   0   0   0   1   9  11  15   9 114   3   0   1   0   1   1   0   0   0   0   0   0   0   0   0   0 |   k = 12
##    0   0   0   0   1   1   4   8  11  12   3  85   1   1   1   0   0   0   1   1   0   0   0   0   0   0   0 |   l = 13
##    0   0   0   0   0   4   5   6  11   8   6   4  42   1   2   2   0   0   0   0   0   0   0   0   0   0   0 |   m = 14
##    0   0   0   0   0   0   4   4   7   4   5   4   2  29   0   0   0   0   0   1   0   0   0   0   0   0   0 |   n = 15
##    0   0   0   0   0   0   1   6   3   3   1   1   3   1  26   0   1   0   0   0   0   0   0   0   0   0   0 |   o = 16
##    0   0   0   0   0   0   2   4   1   0   2   1   3   1   0  23   0   0   0   0   0   0   0   0   0   0   0 |   p = 17
##    0   0   0   0   0   1   2   1   5   4   1   1   2   2   0   0  10   0   0   0   0   0   0   0   0   0   0 |   q = 18
##    0   0   0   0   1   0   1   1   2   3   1   3   1   0   1   1   0   1   0   0   0   0   0   0   0   0   0 |   r = 19
##    0   0   0   0   0   1   0   0   1   1   2   1   0   0   0   1   0   0   7   0   0   0   0   0   0   0   0 |   s = 20
##    0   0   0   0   0   0   0   0   0   3   1   0   1   1   1   0   0   0   0   6   0   0   0   0   0   0   0 |   t = 21
##    0   0   0   0   0   0   0   0   1   1   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   u = 22
##    0   0   0   0   0   0   1   0   0   0   0   0   0   1   1   0   0   1   0   0   0   2   0   0   0   0   0 |   v = 23
##    0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   1   1   0   0   0   0   0   0   0 |   w = 24
##    0   0   0   0   0   0   0   0   0   0   0   0   0   0   1   0   0   0   0   0   0   0   0   0   0   0   0 |   x = 25
##    0   0   0   0   0   0   0   0   0   0   0   0   0   1   0   0   0   0   0   0   0   0   0   0   0   0   0 |   y = 26
##    0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   1   0   0   0   0   0   0   0   0 |   z = 27
##    0   0   0   0   0   0   0   0   0   0   1   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |  aa = 29

dt_sum.c4_5_h2

## 
## === Summary ===
## 
## Correctly Classified Instances         904               33.7188 %
## Incorrectly Classified Instances      1777               66.2812 %
## Kappa statistic                          0.2414
## Mean absolute error                      0.0578
## Root mean squared error                  0.1699
## Relative absolute error                 87.138  %
## Root relative squared error             93.3833 %
## Total Number of Instances             2681     
## 
## === Confusion Matrix ===
## 
##    a   b   c   d   e   f   g   h   i   j   k   l   m   n   o   p   q   r   s   t   u   v   w   x   y   z  aa   <-- classified as
##    0   0   1   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   a = 2
##    0   0   7   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   b = 3
##    0   0  20  11   0   3   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   c = 4
##    0   0   9  40   0  21   0   3   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   d = 5
##    0   0   0  34   0  85  20  10   3   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   e = 6
##    0   0   0   9   0 113  86  26   7   1   1   0   0   0   0   0   0   0   0   0   0   1   0   0   0   0   0 |   f = 7
##    0   0   0   5   0  48 214  53  45   4   4   0   0   0   0   0   0   0   0   0   0   1   0   0   0   0   0 |   g = 8
##    0   0   0   0   0  14 134 122 137  26   1   0   0   0   0   1   0   0   0   0   0   1   0   0   0   0   0 |   h = 9
##    0   0   0   1   0   8  69  42 225  61   5   3   2   0   2   0   0   0   0   0   0   0   0   0   0   0   0 |   i = 10
##    0   0   0   0   0   7  42  26 138 102   5   3   1   0   2   1   0   0   0   0   0   0   0   0   0   0   0 |   j = 11
##    0   0   0   0   0   0  30  14  48  45  24   0   0   0   2   1   0   1   0   0   0   0   0   0   0   0   0 |   k = 12
##    0   0   0   0   0   0  25  16  31  33   6  12   3   0   2   1   0   0   0   0   0   1   0   0   0   0   0 |   l = 13
##    0   0   0   0   0   1  16   5  27  23   2   4  12   0   0   0   0   0   0   0   0   1   0   0   0   0   0 |   m = 14
##    0   0   0   0   0   0  12   7  15  15   4   0   3   0   2   1   0   1   0   0   0   0   0   0   0   0   0 |   n = 15
##    0   0   0   0   0   0   7   4   2  18   2   0   1   0  12   0   0   0   0   0   0   0   0   0   0   0   0 |   o = 16
##    0   0   0   0   0   0   2   0   8  11   4   4   4   0   0   4   0   0   0   0   0   0   0   0   0   0   0 |   p = 17
##    0   0   0   0   0   0   1   4   6  12   1   1   0   0   3   0   0   0   0   0   0   1   0   0   0   0   0 |   q = 18
##    0   0   0   0   0   0   1   1   2   5   2   3   0   0   0   0   0   2   0   0   0   0   0   0   0   0   0 |   r = 19
##    0   0   0   0   0   0   0   2   1   6   2   2   0   0   0   0   0   1   0   0   0   0   0   0   0   0   0 |   s = 20
##    0   0   0   0   0   0   1   0   2   7   0   0   0   0   1   0   0   2   0   0   0   0   0   0   0   0   0 |   t = 21
##    0   0   0   0   0   0   0   0   0   1   0   0   0   0   0   0   0   0   0   0   0   1   0   0   0   0   0 |   u = 22
##    0   0   0   0   0   0   0   0   1   1   0   1   0   0   1   0   0   0   0   0   0   2   0   0   0   0   0 |   v = 23
##    0   0   0   0   0   0   0   0   0   2   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   w = 24
##    0   0   0   0   0   0   0   0   0   0   0   0   0   0   1   0   0   0   0   0   0   0   0   0   0   0   0 |   x = 25
##    0   0   0   0   0   0   0   0   0   0   0   0   1   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |   y = 26
##    0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   1   0   0   0   0   0   0   0   0   0 |   z = 27
##    0   0   0   0   0   0   0   0   0   1   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0   0 |  aa = 29

dt_sum.c4_5_j48_h$details[1]

## pctCorrect 
##   75.82991

dt_sum.c4_5_h2$details[1]

## pctCorrect 
##   33.71876

holdout.test_rings <- holdout.testing$rings
dt.c4_5_j48_h_test <- predict(dt.c4_5_j48_h, newdata = holdout.testing)
holdout.test_levels <- min(holdout.test_rings):max(holdout.test_rings)
dt.c4_5_j48_h_test_cm <- confusionMatrix(factor(dt.c4_5_j48_h_test, levels=holdout.test_levels), factor(holdout.test_rings, levels = holdout.test_levels))
dt.c4_5_j48_h_test_cm$table

##           Reference
## Prediction  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
##         3   0  1  2  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         4   4  5  4  3  5  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         5   1  5  5  9  8  2  1  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         6   0  5 13 27 18 12  6  8  3  2  0  0  1  0  0  0  0  0  0  0  0
##         7   0  0  4 31 45 30 17  8  2  2  2  0  1  0  0  0  0  0  0  0  0
##         8   0  0  1  9 20 39 47 24 17  6  5  4  2  1  3  0  0  0  0  0  0
##         9   0  0  0  3 12 39 46 40 26 21  4  6  5  0  1  0  1  0  0  0  0
##         10  0  0  0  2  8 21 50 53 35 21 13 12  8  5  2  5  4  3  0  0  0
##         11  0  0  0  3  5 15 41 28 37 20 14  3  6  2  6  2  3  1  0  0  0
##         12  0  0  0  0  2  5  9 19 16  7  8  4  2  2  2  1  0  1  1  2  1
##         13  0  0  0  0  2  3  5  9  8  6  8  1  3  7  1  2  4  1  0  0  0
##         14  0  0  0  0  0  0  0  4  1  2  3  2  4  1  0  0  0  3  0  0  1
##         15  0  0  0  0  0  1  2  5  4  2  4  0  3  0  1  1  1  1  0  0  0
##         16  0  0  0  0  0  0  1  0  0  1  4  3  2  1  2  0  1  0  0  0  0
##         17  0  0  0  1  0  1  1  0  0  2  2  0  0  0  1  0  0  0  0  1  1
##         18  0  0  0  0  0  0  0  1  2  0  1  0  2  0  1  0  1  1  0  0  0
##         19  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         20  0  0  0  0  0  0  0  1  0  0  0  0  1  0  1  1  0  1  0  0  0
##         21  0  0  0  0  0  0  0  0  0  3  1  0  0  1  0  1  0  0  0  1  0
##         22  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         23  0  0  0  0  0  0  0  1  0  0  0  0  0  0  0  0  0  0  0  0  0
##         24  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         25  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         26  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         27  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##           Reference
## Prediction 24 25 26 27
##         3   0  0  0  0
##         4   0  0  0  0
##         5   0  0  0  0
##         6   0  0  0  0
##         7   0  0  0  0
##         8   0  0  0  0
##         9   0  0  0  0
##         10  0  0  0  0
##         11  0  0  0  0
##         12  0  0  0  0
##         13  0  0  0  0
##         14  0  0  0  0
##         15  0  0  0  0
##         16  0  0  0  1
##         17  0  0  0  0
##         18  0  0  0  0
##         19  0  0  0  0
##         20  0  0  0  0
##         21  0  0  0  0
##         22  0  0  0  0
##         23  0  0  0  0
##         24  0  0  0  0
##         25  0  0  0  0
##         26  0  0  0  0
##         27  0  0  0  0

dt.c4_5_j48_h_test_cm$overall[1]

##  Accuracy 
## 0.2092676

#dt.c4_5_h2
dt.c4_5_h2_test <- predict(dt.c4_5_h2, newdata = holdout.testing)
dt.c4_5_h2_test_cm <- confusionMatrix(factor(dt.c4_5_h2_test, levels=holdout.test_levels), factor(holdout.test_rings, levels = holdout.test_levels))
dt.c4_5_h2_test_cm$table

##           Reference
## Prediction  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
##         3   0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         4   5  8  6  2  1  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         5   0  8 15 10 11  3  1  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         6   0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         7   0  0  8 61 53 21  5  5  1  3  1  0  0  0  0  0  0  0  0  0  0
##         8   0  0  0 10 45 78 91 44 32  7 10  8  8  3  2  1  0  0  1  0  0
##         9   0  0  0  3 12 33 35 30 15 16  5  3  4  3  0  1  1  1  0  0  0
##         10  0  0  0  0  3 25 72 82 63 33 21 10 11  3  4  6  5  2  0  1  0
##         11  0  0  0  1  0  6 16 31 36 26 21  5 10  7 12  3  6  5  0  3  1
##         12  0  0  0  0  0  2  4  6  2  6  3  2  0  1  1  0  0  1  0  0  0
##         13  0  0  0  1  0  0  0  2  0  1  0  1  5  0  0  0  0  1  0  0  0
##         14  0  0  0  0  0  0  0  0  1  1  1  3  2  3  1  1  0  0  0  0  2
##         15  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         16  0  0  0  0  0  0  1  1  1  0  5  1  0  0  1  1  2  0  0  0  0
##         17  0  0  0  0  0  0  1  0  0  0  1  0  0  0  0  0  0  0  0  0  0
##         18  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         19  0  0  0  0  0  0  0  0  0  0  1  1  0  0  0  0  0  2  0  0  0
##         20  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         21  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         22  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         23  0  0  0  0  0  0  0  0  0  2  0  1  0  0  0  0  1  0  0  0  0
##         24  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         25  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         26  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##         27  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0
##           Reference
## Prediction 24 25 26 27
##         3   0  0  0  0
##         4   0  0  0  0
##         5   0  0  0  0
##         6   0  0  0  0
##         7   0  0  0  0
##         8   0  0  0  0
##         9   0  0  0  0
##         10  0  0  0  0
##         11  0  0  0  1
##         12  0  0  0  0
##         13  0  0  0  0
##         14  0  0  0  0
##         15  0  0  0  0
##         16  0  0  0  0
##         17  0  0  0  0
##         18  0  0  0  0
##         19  0  0  0  0
##         20  0  0  0  0
##         21  0  0  0  0
##         22  0  0  0  0
##         23  0  0  0  0
##         24  0  0  0  0
##         25  0  0  0  0
##         26  0  0  0  0
##         27  0  0  0  0

dt.c4_5_h2_test_cm$overall[1]

##  Accuracy 
## 0.2361734

C4.5 with refined dataset

To attempt attainment of high accuracy, it’s worth looking to run the very same decision tree functions against a streamline classification aim, with a more targeted formula. Using raw rings and the classification levels amounted to nearly 30 possible outcomes, so bringing that down do a concrete tiered factor of 3 age groups has to make things not only more performant but it’s easier to be more accurate when the intended classification type has a larger scope.

dt.formula <- as.formula(age_group ~ weight.shell + height + diameter)

dt.c4_5_j48_h_a <- J48(dt.formula, holdout_age_groups.training) 
dt_sum.c4_5_j48_h_a <- summary(dt.c4_5_j48_h_a)
dt.c4_5_j48_h_a_party <- as.party(dt.c4_5_j48_h_a)
#
dt_sum.c4_5_j48_h_a

## 
## === Summary ===
## 
## Correctly Classified Instances        1892               70.5707 %
## Incorrectly Classified Instances       789               29.4293 %
## Kappa statistic                          0.5053
## Mean absolute error                      0.2797
## Root mean squared error                  0.374 
## Relative absolute error                 68.3388 %
## Root relative squared error             82.6712 %
## Total Number of Instances             2681     
## 
## === Confusion Matrix ===
## 
##     a    b    c   <-- classified as
##  1084  223   14 |    a = young
##   243  630   37 |    b = middle
##    79  193  178 |    c = old

#
length(dt.c4_5_j48_h_a_party)

## [1] 103

width(dt.c4_5_j48_h_a_party)

## [1] 52

depth(dt.c4_5_j48_h_a_party)

## [1] 11

#
plot(dt.c4_5_j48_h_a_party)

The caret train J48 argument with updated formula and simpler classification

dt.c4_5_h2_a <- train(dt.formula, method="J48", holdout_age_groups.training, tuneLength = 8)

dt_sum.c4_5_h2_a <- summary(dt.c4_5_h2_a)
dt_sum.c4_5_h2_a_final <- summary(dt.c4_5_h2_a$finalModel)
#
dt_sum.c4_5_h2_a

## 
## === Summary ===
## 
## Correctly Classified Instances        1821               67.9224 %
## Incorrectly Classified Instances       860               32.0776 %
## Kappa statistic                          0.4683
## Mean absolute error                      0.2995
## Root mean squared error                  0.387 
## Relative absolute error                 73.1807 %
## Root relative squared error             85.5498 %
## Total Number of Instances             2681     
## 
## === Confusion Matrix ===
## 
##     a    b    c   <-- classified as
##  1048  229   44 |    a = young
##   234  590   86 |    b = middle
##    69  198  183 |    c = old

#
dt.c4_5_h2_a_finalModel <- dt.c4_5_h2_a$finalModel
dt.c4_5_h2_a_finalModel_party <- as.party(dt.c4_5_h2_a_finalModel)
#
length(dt.c4_5_h2_a_finalModel_party)

## [1] 33

width(dt.c4_5_h2_a_finalModel_party)

## [1] 17

depth(dt.c4_5_h2_a_finalModel_party)

## [1] 8

#
plot(dt.c4_5_h2_a_finalModel_party)

dt_sum.c4_5_j48_h_a$details[1]

## pctCorrect 
##   70.57068

dt_sum.c4_5_h2_a$details[1]

## pctCorrect 
##   67.92242

#holdout.test_rings <- holdout.testing$rings
dt.c4_5_j48_h_a_test <- predict(dt.c4_5_j48_h_a, newdata = holdout_age_groups.testing)
#holdout.test_levels <- min(holdout.test_rings):max(holdout.test_rings)
#dt.c4_5_j48_h_a_test_cm <- confusionMatrix(factor(dt.c4_5_j48_h_test, levels=holdout.test_levels), factor(holdout.test_rings, levels = holdout.test_levels))
dt.c4_5_j48_h_a_test_cm <- confusionMatrix(dt.c4_5_j48_h_a_test, holdout_age_groups.testing$age_group)
dt.c4_5_j48_h_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    517    147  34
##     middle   119    267 138
##     old       21     33  62

dt.c4_5_j48_h_a_test_cm$overall[1]

## Accuracy 
## 0.632287

#dt.c4_5_h2
dt.c4_5_h2_a_test <- predict(dt.c4_5_h2_a, newdata = holdout_age_groups.testing)
dt.c4_5_h2_a_test_cm <- confusionMatrix(dt.c4_5_h2_a_test, holdout_age_groups.testing$age_group)
dt.c4_5_h2_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    510    134  27
##     middle   120    263 123
##     old       27     50  84

dt.c4_5_h2_a_test_cm$overall[1]

##  Accuracy 
## 0.6405082

C4.5 with cross-validation techniques

Given how the accuracy between the two form of C4.5 model generation narrowed to an absolute percentage delta of lest than 1 percent, coupled with the speed at which the J48 function returns, the next phase of experimentation will occur only with this function and the relevant training control options.

WOW("J48")

## -U      Use unpruned tree.
## -O      Do not collapse tree.
## -C <pruning confidence>
##         Set confidence threshold for pruning.  (default 0.25)
##  Number of arguments: 1.
## -M <minimum number of instances>
##         Set minimum number of instances per leaf.  (default 2)
##  Number of arguments: 1.
## -R      Use reduced error pruning.
## -N <number of folds>
##         Set number of folds for reduced error pruning. One fold is
##         used as pruning set.  (default 3)
##  Number of arguments: 1.
## -B      Use binary splits only.
## -S      Do not perform subtree raising.
## -L      Do not clean up after the tree has been built.
## -A      Laplace smoothing for predicted probabilities.
## -J      Do not use MDL correction for info gain on numeric
##         attributes.
## -Q <seed>
##         Seed for random data shuffling (default 1).
##  Number of arguments: 1.
## -doNotMakeSplitPointActualValue
##         Do not make split point actual value.
## -output-debug-info
##         If set, classifier is run in debug mode and may output
##         additional info to the console
## -do-not-check-capabilities
##         If set, classifier capabilities are not checked before
##         classifier is built (use with caution).
## -num-decimal-places
##         The number of decimal places for the output of numbers in
##         the model (default 2).
##  Number of arguments: 1.
## -batch-size
##         The desired batch size for batch prediction (default 100).
##  Number of arguments: 1.

dt.c4_5_j48_kf_a <- train(dt.formula, method="J48", abalone_data_cleansed_age_groups, tuneLength = 8, trControl = cv.train_control_8)

dt.c4_5_j48_r5kf8_a <- train(dt.formula, method="J48", abalone_data_cleansed_age_groups, tuneLength = 8, trControl = cv.train_control_8_5)

dt.c4_5_j48_r5kf13_a <- train(dt.formula, method="J48", abalone_data_cleansed_age_groups, tuneLength = 8, trControl = cv.train_control_13_5)

dt.c4_5_j48_r8kf13_a <- train(dt.formula, method="J48", abalone_data_cleansed_age_groups, tuneLength = 8, trControl = cv.train_control_13_8)

dt_sum.c4_5_j48_kf_a <- summary(dt.c4_5_j48_kf_a)
dt.c4_5_j48_kf_a_final <- summary(dt.c4_5_j48_kf_a$finalModel)
#
dt_sum.c4_5_j48_kf_a

## 
## === Summary ===
## 
## Correctly Classified Instances        2771               68.9475 %
## Incorrectly Classified Instances      1248               31.0525 %
## Kappa statistic                          0.4824
## Mean absolute error                      0.2887
## Root mean squared error                  0.3799
## Relative absolute error                 70.4376 %
## Root relative squared error             83.9297 %
## Total Number of Instances             4019     
## 
## === Confusion Matrix ===
## 
##     a    b    c   <-- classified as
##  1647  268   63 |    a = young
##   402  831  124 |    b = middle
##    95  296  293 |    c = old

#
dt.c4_5_j48_kf_a_finalModel <- dt.c4_5_h2_a$finalModel
dt.c4_5_j48_kf_a_finalModel_party <- as.party(dt.c4_5_h2_a$finalModel)
#
length(dt.c4_5_j48_kf_a_finalModel_party)

## [1] 33

width(dt.c4_5_j48_kf_a_finalModel_party)

## [1] 17

depth(dt.c4_5_j48_kf_a_finalModel_party)

## [1] 8

#
plot(dt.c4_5_j48_kf_a_finalModel_party)

dt_sum.c4_5_r5kf8_a <- summary(dt.c4_5_j48_r5kf8_a)
dt.c4_5_j48_r5kf8_a_final <- summary(dt.c4_5_j48_r5kf8_a$finalModel)
#
dt_sum.c4_5_r5kf8_a

## 
## === Summary ===
## 
## Correctly Classified Instances        2694               67.0316 %
## Incorrectly Classified Instances      1325               32.9684 %
## Kappa statistic                          0.4385
## Mean absolute error                      0.3154
## Root mean squared error                  0.3971
## Relative absolute error                 76.9366 %
## Root relative squared error             87.7163 %
## Total Number of Instances             4019     
## 
## === Confusion Matrix ===
## 
##     a    b    c   <-- classified as
##  1696  239   43 |    a = young
##   516  746   95 |    b = middle
##   168  264  252 |    c = old

#
dt.c4_5_j48_r5kf8_a_finalModel <- dt.c4_5_j48_r5kf8_a$finalModel
dt.c4_5_j48_r5kf8_a_finalModel_party <- as.party(dt.c4_5_j48_r5kf8_a_finalModel)
#
length(dt.c4_5_j48_r5kf8_a_finalModel_party)

## [1] 39

width(dt.c4_5_j48_r5kf8_a_finalModel_party)

## [1] 20

depth(dt.c4_5_j48_r5kf8_a_finalModel_party)

## [1] 9

#
plot(dt.c4_5_j48_r5kf8_a_finalModel_party)

dt_sum.c4_5_r5kf13_a <- summary(dt.c4_5_j48_r5kf13_a)
dt.c4_5_j48_r5kf13_a_final <- summary(dt.c4_5_j48_r5kf13_a$finalModel)
#
dt_sum.c4_5_r5kf13_a

## 
## === Summary ===
## 
## Correctly Classified Instances        2731               67.9522 %
## Incorrectly Classified Instances      1288               32.0478 %
## Kappa statistic                          0.4628
## Mean absolute error                      0.2957
## Root mean squared error                  0.3845
## Relative absolute error                 72.1388 %
## Root relative squared error             84.9372 %
## Total Number of Instances             4019     
## 
## === Confusion Matrix ===
## 
##     a    b    c   <-- classified as
##  1655  264   59 |    a = young
##   436  801  120 |    b = middle
##   113  296  275 |    c = old

#
dt.c4_5_j48_r5kf13_a_finalModel <- dt.c4_5_j48_r5kf13_a$finalModel
dt.c4_5_j48_r5kf13_a_finalModel_party <- as.party(dt.c4_5_j48_r5kf13_a_finalModel)
#
length(dt.c4_5_j48_r5kf13_a_finalModel_party)

## [1] 59

width(dt.c4_5_j48_r5kf13_a_finalModel_party)

## [1] 30

depth(dt.c4_5_j48_r5kf13_a_finalModel_party)

## [1] 9

#
plot(dt.c4_5_j48_r5kf13_a_finalModel_party)

dt_sum.c4_5_r8kf13_a <- summary(dt.c4_5_j48_r8kf13_a)
dt.c4_5_j48_r8kf13_a_final <- summary(dt.c4_5_j48_r8kf13_a$finalModel)
#
dt_sum.c4_5_r8kf13_a

## 
## === Summary ===
## 
## Correctly Classified Instances        2731               67.9522 %
## Incorrectly Classified Instances      1288               32.0478 %
## Kappa statistic                          0.4628
## Mean absolute error                      0.2957
## Root mean squared error                  0.3845
## Relative absolute error                 72.1388 %
## Root relative squared error             84.9372 %
## Total Number of Instances             4019     
## 
## === Confusion Matrix ===
## 
##     a    b    c   <-- classified as
##  1655  264   59 |    a = young
##   436  801  120 |    b = middle
##   113  296  275 |    c = old

#
dt.c4_5_j48_r8kf13_a_finalModel <- dt.c4_5_j48_r8kf13_a$finalModel
dt.c4_5_j48_r8kf13_a_finalModel_party <- as.party(dt.c4_5_j48_r8kf13_a_finalModel)
#
length(dt.c4_5_j48_r8kf13_a_finalModel_party)

## [1] 59

width(dt.c4_5_j48_r8kf13_a_finalModel_party)

## [1] 30

depth(dt.c4_5_j48_r8kf13_a_finalModel_party)

## [1] 9

#
plot(dt.c4_5_j48_r8kf13_a_finalModel_party)

dt_sum.c4_5_j48_kf_a$details[1]

## pctCorrect 
##    68.9475

dt_sum.c4_5_r5kf8_a$details[1]

## pctCorrect 
##    67.0316

dt_sum.c4_5_r5kf13_a$details[1]

## pctCorrect 
##   67.95223

dt.c4_5_j48_kf_a_test <- predict(dt.c4_5_j48_kf_a, newdata = holdout_age_groups.testing)
dt.c4_5_j48_kf_a_test_cm <- confusionMatrix(dt.c4_5_j48_kf_a_test, holdout_age_groups.testing$age_group)
dt.c4_5_j48_kf_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    543    146  28
##     middle    90    257 116
##     old       24     44  90

dt.c4_5_j48_kf_a_test_cm$overall[1]

##  Accuracy 
## 0.6651719

dt.c4_5_j48_r5kf8_a_test <- predict(dt.c4_5_j48_r5kf8_a, newdata = holdout_age_groups.testing)
dt.c4_5_j48_r5kf8_a_test_prob <- predict(dt.c4_5_j48_r5kf8_a, newdata = holdout_age_groups.testing, type = "prob")
dt.c4_5_j48_r5kf8_a_test_cm <- confusionMatrix(dt.c4_5_j48_r5kf8_a_test, holdout_age_groups.testing$age_group)
dt.c4_5_j48_r5kf8_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    565    186  47
##     middle    78    227 108
##     old       14     34  79

dt.c4_5_j48_r5kf8_a_test_cm$overall[1]

##  Accuracy 
## 0.6509716

dt.c4_5_j48_r5kf13_a_test <- predict(dt.c4_5_j48_r5kf13_a, newdata = holdout_age_groups.testing)
dt.c4_5_j48_r5kf13_a_test_cm <- confusionMatrix(dt.c4_5_j48_r5kf13_a_test, holdout_age_groups.testing$age_group)
dt.c4_5_j48_r5kf13_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    547    159  32
##     middle    88    244 114
##     old       22     44  88

dt.c4_5_j48_r5kf13_a_test_cm$overall[1]

##  Accuracy 
## 0.6569507

dt.c4_5_j48_r8kf13_a_test <- predict(dt.c4_5_j48_r8kf13_a, newdata = holdout_age_groups.testing)
dt.c4_5_j48_r8kf13_a_test_prob <- predict(dt.c4_5_j48_r8kf13_a, newdata = holdout_age_groups.testing, type = "prob")
dt.c4_5_j48_r8kf13_a_test_cm <- confusionMatrix(dt.c4_5_j48_r8kf13_a_test, holdout_age_groups.testing$age_group)
dt.c4_5_j48_r8kf13_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    547    159  32
##     middle    88    244 114
##     old       22     44  88

dt.c4_5_j48_r8kf13_a_test_cm$overall[1]

##  Accuracy 
## 0.6569507

Random Forest Holdout

The same holdout values derived in Task 2 that were used for C4.5, will be applied for testing and training the Random Forest.

dt.rf_h_a <- train(dt.formula, data = holdout_age_groups.training, method = "rf", prox= TRUE)

## note: only 2 unique complexity parameters in default grid. Truncating the grid to 2 .

dt.rf_h_a_finalModel <- dt.rf_h_a$finalModel
dt_sum.rf_h_a <- summary(dt.rf_h_a)
#
dt.rf_h_a_finalModel$forest[11]

## $nrnodes
## [1] 1561

dt.rf_h_a_finalModel$forest[12]

## $ntree
## [1] 500

#
plot(dt.rf_h_a)

plot(dt.rf_h_a_finalModel)

dt.rf_h_a_test <- predict(dt.rf_h_a, newdata = holdout_age_groups.testing)

dt.rf_h_a_test_cm <- confusionMatrix(dt.rf_h_a_test, holdout_age_groups.testing$age_group)
dt.rf_h_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    500    161  36
##     middle   116    207 114
##     old       41     79  84

dt.rf_h_a_test_cm$overall[1]

##  Accuracy 
## 0.5911809

dt.hrf_h_a <- holdoutRF(dt.formula, holdout_age_groups.training)
dt.hrf_h_a_prob <- holdoutRF(dt.formula, holdout_age_groups.training, probability = TRUE)

#dt.hrf_h_a_finalModel <- dt.hrf_h_a$finalModel
dt_sum.hrf_h_a <- summary(dt.hrf_h_a)
#
dt.hrf_h_a$rf1

## Ranger result
## 
## Call:
##  ranger(..., importance = "permutation", case.weights = weights,      replace = FALSE, holdout = TRUE) 
## 
## Type:                             Classification 
## Number of trees:                  500 
## Sample size:                      2681 
## Number of independent variables:  3 
## Mtry:                             1 
## Target node size:                 1 
## Variable importance mode:         permutation 
## OOB prediction error:             37.69 %

dt.hrf_h_a$rf2

## Ranger result
## 
## Call:
##  ranger(..., importance = "permutation", case.weights = 1 - weights,      replace = FALSE, holdout = TRUE) 
## 
## Type:                             Classification 
## Number of trees:                  500 
## Sample size:                      2681 
## Number of independent variables:  3 
## Mtry:                             1 
## Target node size:                 1 
## Variable importance mode:         permutation 
## OOB prediction error:             34.17 %

dt.hrf1_h_a_test <- predict(dt.hrf_h_a$rf1, holdout_age_groups.testing)
dt.hrf1_h_a_test_prob <- predict(dt.hrf_h_a_prob$rf1, holdout_age_groups.testing)

dt.hrf1_h_a_test_cm <- confusionMatrix(dt.hrf1_h_a_test$predictions, holdout_age_groups.testing$age_group)
dt.hrf1_h_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    520    163  41
##     middle   113    225 124
##     old       24     59  69

dt.hrf1_h_a_test_cm$overall[1]

##  Accuracy 
## 0.6083707

#
dt.hrf2_h_a_test <- predict(dt.hrf_h_a$rf2, holdout_age_groups.testing)
dt.hrf2_h_a_test_prob <- predict(dt.hrf_h_a_prob$rf2, holdout_age_groups.testing)

dt.hrf2_h_a_test_cm <- confusionMatrix(dt.hrf2_h_a_test$predictions, holdout_age_groups.testing$age_group)
dt.hrf2_h_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    519    156  33
##     middle   122    233 132
##     old       16     58  69

dt.hrf2_h_a_test_cm$overall[1]

##  Accuracy 
## 0.6136024

Random Forest Cross-validation

Even though opinion in the Data Science community is that a Random Forest uses techniques that effectively provide internal solutions for cross-validation while training, setting an explcit control will ensure a complete rotation of data for testing and training.

dt.rf_cv_r5kf8_a <- train(dt.formula, data = abalone_data_cleansed_age_groups, method = "rf", prox= TRUE, trControl = cv.train_control_8_5)

## note: only 2 unique complexity parameters in default grid. Truncating the grid to 2 .

dt.rf_cv_r5kf8_a_finalModel <- dt.rf_cv_r5kf8_a$finalModel
dt_sum.rf_cv_r5kf8_a <- summary(dt.rf_cv_r5kf8_a)
#
dt.rf_cv_r5kf8_a_finalModel$forest[11]

## $nrnodes
## [1] 2371

dt.rf_cv_r5kf8_a_finalModel$forest[12]

## $ntree
## [1] 500

#
plot(dt.rf_cv_r5kf8_a)

plot(dt.rf_cv_r5kf8_a_finalModel)

dt.rf_cv_r5kf8_a_test <- predict(dt.rf_cv_r5kf8_a, newdata = holdout_age_groups.testing)
dt.rf_cv_r5kf8_a_test_prob <- predict(dt.rf_cv_r5kf8_a, newdata = holdout_age_groups.testing, type = "prob")

dt.rf_cv_r5kf8_a_test_cm <- confusionMatrix(dt.rf_cv_r5kf8_a_test, holdout_age_groups.testing$age_group)
dt.rf_cv_r5kf8_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    650      6   3
##     middle     5    439   4
##     old        2      2 227

dt.rf_cv_r5kf8_a_test_cm$overall[1]

##  Accuracy 
## 0.9835575

dt.rf_cv_r5kf8_a_test2 <- predict(dt.rf_cv_r5kf8_a)
dt.rf_cv_r5kf8_a_test2_prob <- predict(dt.rf_cv_r5kf8_a, newdata = holdout_age_groups.testing, type = "prob")

dt.rf_cv_r5kf8_a_test2_cm <- confusionMatrix(dt.rf_cv_r5kf8_a_test2, abalone_data_cleansed_age_groups$age_group)
dt.rf_cv_r5kf8_a_test2_cm$table

##           Reference
## Prediction young middle  old
##     young   1955     28   13
##     middle    18   1324   13
##     old        5      5  658

dt.rf_cv_r5kf8_a_test2_cm$overall[1]

##  Accuracy 
## 0.9795969

Random Forest Cross-validation with Holdout

dt.rf_cv2_r5kf8_a <- train(dt.formula, data = holdout_age_groups.training, method = "rf", prox= TRUE, trControl = cv.train_control_8_5)

## note: only 2 unique complexity parameters in default grid. Truncating the grid to 2 .

dt.rf_cv2_r5kf8_a_finalModel <- dt.rf_cv2_r5kf8_a$finalModel
dt_sum.rf_cv2_r5kf8_a <- summary(dt.rf_cv2_r5kf8_a)
#
dt.rf_cv2_r5kf8_a_finalModel$forest[11]

## $nrnodes
## [1] 1557

dt.rf_cv2_r5kf8_a_finalModel$forest[12]

## $ntree
## [1] 500

#
plot(dt.rf_cv2_r5kf8_a)

plot(dt.rf_cv2_r5kf8_a_finalModel)

dt.rf_cv2_r5kf8_a_test <- predict(dt.rf_cv2_r5kf8_a, newdata = holdout_age_groups.testing)
dt.rf_cv2_r5kf8_a_test_prob <- predict(dt.rf_cv2_r5kf8_a, newdata = holdout_age_groups.testing, type = "prob")

dt.rf_cv2_r5kf8_a_test_cm <- confusionMatrix(dt.rf_cv2_r5kf8_a_test, holdout_age_groups.testing$age_group)
dt.rf_cv2_r5kf8_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    503    163  37
##     middle   116    208 116
##     old       38     76  81

dt.rf_cv2_r5kf8_a_test_cm$overall[1]

##  Accuracy 
## 0.5919283

Random Forest Leave-one-out

As with the C4.5 decision tree, Leave-one-out Cross-validation is not suitable for this type of model.

Random Forest Decision Tree Conclusion

Random forests are good for avoiding over-fitting, so long as you know what you’re doing, particularly with regard to cross-validation.

Decision Tree Conclusion

Given all the data processing and feature selection work, the results from the decision tree have not been a fruitful as one might have hoped. Perhaps further investigation into more fine tuning could help yield better results.

Naive Bayes formula and simpler classification

Precedent was set in the previous task to use a specific formula to target key predictors (weight.shell, height, diameter) and classify data instances based on a factor representing simplified age grouping; that precedent applies to the modelling in this chapter and following sections.

Naive Bayes with holdout

nb.h_a <- NaiveBayes(dt.formula, data=holdout_age_groups.training)

plot(nb.h_a)

What’s interesting about these Naive Bayes plots is that they suggest the merit of using this techniques to select features that could be used when creating a formula for use with another model. Another aspect worth noting is how the height and diameter probability graphs are extremely similar, which could suggest redundancy, where another feature could have been used as a classifier variable.

nb.h_a_test <- predict(nb.h_a, holdout_age_groups.testing)
nb.h_a_test_prob <- predict(nb.h_a, holdout_age_groups.testing, type = "prob")
# summarize results
nb.h_a_test_cm <- confusionMatrix(nb.h_a_test$class, holdout_age_groups.testing$age_group)
nb.h_a_test_cm

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction young middle old
##     young    468    121  45
##     middle   186    293 149
##     old        3     33  40
## 
## Overall Statistics
##                                           
##                Accuracy : 0.5987          
##                  95% CI : (0.5718, 0.6251)
##     No Information Rate : 0.491           
##     P-Value [Acc > NIR] : 1.811e-15       
##                                           
##                   Kappa : 0.3318          
##  Mcnemar's Test P-Value : < 2.2e-16       
## 
## Statistics by Class:
## 
##                      Class: young Class: middle Class: old
## Sensitivity                0.7123        0.6555     0.1709
## Specificity                0.7562        0.6240     0.9674
## Pos Pred Value             0.7382        0.4666     0.5263
## Neg Pred Value             0.7315        0.7831     0.8463
## Prevalence                 0.4910        0.3341     0.1749
## Detection Rate             0.3498        0.2190     0.0299
## Detection Prevalence       0.4738        0.4694     0.0568
## Balanced Accuracy          0.7343        0.6397     0.5692

Naive Bayes with Repeated K-folds Cross-validation

nb.r5kf8_a <- train(dt.formula, data=abalone_data_cleansed_age_groups, trControl = cv.train_control_8_5, method="nb")

plot(nb.r5kf8_a)

nb.r5kf8_a_test <- predict(nb.r5kf8_a, holdout_age_groups.testing)
nb.r5kf8_a_test_prob <- predict(nb.r5kf8_a, holdout_age_groups.testing, type = "prob")
# summarize results
nb.r5kf8_a_test_cm <- confusionMatrix(nb.r5kf8_a_test, holdout_age_groups.testing$age_group)
nb.r5kf8_a_test_cm

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction young middle old
##     young    481    128  53
##     middle   174    288 145
##     old        2     31  36
## 
## Overall Statistics
##                                          
##                Accuracy : 0.6016         
##                  95% CI : (0.5748, 0.628)
##     No Information Rate : 0.491          
##     P-Value [Acc > NIR] : 3.029e-16      
##                                          
##                   Kappa : 0.3321         
##  Mcnemar's Test P-Value : < 2.2e-16      
## 
## Statistics by Class:
## 
##                      Class: young Class: middle Class: old
## Sensitivity                0.7321        0.6443    0.15385
## Specificity                0.7342        0.6420    0.97011
## Pos Pred Value             0.7266        0.4745    0.52174
## Neg Pred Value             0.7396        0.7825    0.84397
## Prevalence                 0.4910        0.3341    0.17489
## Detection Rate             0.3595        0.2152    0.02691
## Detection Prevalence       0.4948        0.4537    0.05157
## Balanced Accuracy          0.7332        0.6431    0.56198

Naive Bayes with Leave-one-out Cross-validation

nb.loo_a <- train(dt.formula, data=abalone_data_cleansed_age_groups, trControl = loocv.train_control, method="nb")

plot(nb.loo_a)

nb.loo_a_test <- predict(nb.loo_a, holdout_age_groups.testing)
# summarize results
nb.loo_a_test_cm <- confusionMatrix(nb.loo_a_test, holdout_age_groups.testing$age_group)
nb.loo_a_test_cm

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction young middle old
##     young    481    128  53
##     middle   174    288 145
##     old        2     31  36
## 
## Overall Statistics
##                                          
##                Accuracy : 0.6016         
##                  95% CI : (0.5748, 0.628)
##     No Information Rate : 0.491          
##     P-Value [Acc > NIR] : 3.029e-16      
##                                          
##                   Kappa : 0.3321         
##  Mcnemar's Test P-Value : < 2.2e-16      
## 
## Statistics by Class:
## 
##                      Class: young Class: middle Class: old
## Sensitivity                0.7321        0.6443    0.15385
## Specificity                0.7342        0.6420    0.97011
## Pos Pred Value             0.7266        0.4745    0.52174
## Neg Pred Value             0.7396        0.7825    0.84397
## Prevalence                 0.4910        0.3341    0.17489
## Detection Rate             0.3595        0.2152    0.02691
## Detection Prevalence       0.4948        0.4537    0.05157
## Balanced Accuracy          0.7332        0.6431    0.56198

Accuracy comparison of NB models

nb.h_a_test_cm$overall[1]

##  Accuracy 
## 0.5986547

nb.r5kf8_a_test_cm$overall[1]

##  Accuracy 
## 0.6016442

nb.loo_a_test_cm$overall[1]

##  Accuracy 
## 0.6016442

KNN with holdout

knn.h_a <- train(dt.formula, data=holdout_age_groups.training, method = "knn")

plot(knn.h_a)

knn.h_a_test <- predict(knn.h_a, holdout_age_groups.testing)
knn.h_a_test_prob <- predict(knn.h_a, holdout_age_groups.testing, type = "prob")
# summarize results
knn.h_a_test_cm <- confusionMatrix(knn.h_a_test, holdout_age_groups.testing$age_group)
knn.h_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    531    160  35
##     middle   106    233 131
##     old       20     54  68

KNN with Repeated K-folds Cross-validation

knn.r5kf8_a <- train(dt.formula, data=abalone_data_cleansed_age_groups, trControl = cv.train_control_8_5, method = "knn")

plot(knn.r5kf8_a)

knn.r5kf8_a_test <- predict(knn.r5kf8_a, holdout_age_groups.testing)
knn.r5kf8_a_test_prob <- predict(knn.r5kf8_a, holdout_age_groups.testing, type = "prob")
# summarize results
knn.r5kf8_a_test_cm <- confusionMatrix(knn.r5kf8_a_test, holdout_age_groups.testing$age_group)
knn.r5kf8_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    541    127  36
##     middle    99    279  97
##     old       17     41 101

Naive Bayes with Leave-one-out Cross-validation

knn.loo_a <- train(dt.formula, data=abalone_data_cleansed_age_groups, trControl = loocv.train_control, method="knn")

plot(knn.loo_a)

knn.loo_a_test <- predict(knn.loo_a, holdout_age_groups.testing)
# summarize results
knn.loo_a_test_cm <- confusionMatrix(knn.loo_a_test, holdout_age_groups.testing$age_group)
knn.loo_a_test_cm$table

##           Reference
## Prediction young middle old
##     young    543    131  34
##     middle    94    276  98
##     old       20     40 102

Accuracy comparison of KNN models

knn.h_a_test_cm$overall[1]

##  Accuracy 
## 0.6218236

knn.r5kf8_a_test_cm$overall[1]

##  Accuracy 
## 0.6883408

knn.loo_a_test_cm$overall[1]

##  Accuracy 
## 0.6883408

KNN model conclusion

Once again, sufficient cross-validation appears to be about as good as using the leave-one-out technique for improving the accuracy of the model but cheaper to train than leave-one-out. In this case, there’s quite a marked jump in improvement between the holdout version and the other two forms of training. The holdout KNN is only marginally more accurate than the Naive Bayes while the k-folds and leave-one-out methods are more than 10% more accurate. The results suggest that KNN could be the most suitable model for age group classification of Abalone.

C4.5 Decision Tree candidate, 8 folds & 5 repetitions

pred_dt.c4_5_highest_probs <- apply(dt.c4_5_j48_r5kf8_a_test_prob, 1, "max") 
pred_dt.c4_5_correct <- dt.c4_5_j48_r5kf8_a_test == holdout_age_groups.testing$age_group

pred_dt.c4_5 <- prediction(pred_dt.c4_5_highest_probs, pred_dt.c4_5_correct)

## precision/recall curve (x-axis: recall, y-axis: precision)
pr_dt.c4_5 <- performance(pred_dt.c4_5, "prec", "rec")
plot(pr_dt.c4_5)

This is a strange line but appears to suggest that the precision of this model drops off dramatically as there’s a lot of overlap between false and true positives.

C4.5 Decision Tree candidate, 13 folds & 8 repetitions

pred_dt.c4_5_r8kf13_highest_probs <- apply(dt.c4_5_j48_r8kf13_a_test_prob, 1, "max") 
pred_dt.c4_5_r8kf13_correct <- dt.c4_5_j48_r8kf13_a_test == holdout_age_groups.testing$age_group

pred_dt.c4_5_r8kf13 <- prediction(pred_dt.c4_5_r8kf13_highest_probs, pred_dt.c4_5_r8kf13_correct)

## precision/recall curve (x-axis: recall, y-axis: precision)
pr_dt.c4_5_r8kf13 <- performance(pred_dt.c4_5_r8kf13, "prec", "rec")
plot(pr_dt.c4_5_r8kf13)

This line suggests is prettier linear relationship between precision & recall, which is at least better than the previous graph but a better line would remain higher on the y only dropping off towards 1.0 on the y.

Random Forest Decision Tree repeated k-folds candidate (overfit)

pred_dt.rf_highest_probs <- apply(dt.rf_cv_r5kf8_a_test_prob, 1, "max") 
pred_dt.rf_correct <- dt.rf_cv_r5kf8_a_test == holdout_age_groups.testing$age_group

pred_dt.rf <- prediction(pred_dt.rf_highest_probs, pred_dt.rf_correct)

## precision/recall curve (x-axis: recall, y-axis: precision)
pr_dt.rf <- performance(pred_dt.rf, "prec", "rec")
plot(pr_dt.rf)

This is the over-fit example which show an example of what the line should be like if precision of classification stayed more or less constant as recall scales.

Random Forest Decision Tree holdout candidate

#dt.hrf2_h_a_test_prob
pred_dt.hrf2_h_highest_probs <- apply(dt.hrf2_h_a_test_prob$predictions, 1, "max") 
pred_dt.hrf2_h_correct <- dt.hrf2_h_a_test$predictions == holdout_age_groups.testing$age_group

pred_dt.hrf2_h <- prediction(pred_dt.hrf2_h_highest_probs, pred_dt.hrf2_h_correct)

## precision/recall curve (x-axis: recall, y-axis: precision)
pr_dt.hrf2_h <- performance(pred_dt.hrf2_h, "prec", "rec")
plot(pr_dt.hrf2_h)

This line show a saw-tooth pattern that is apparently common in this sort of graph; the slope is approximately the same as the better C4.5 line though the area under the line might well be higher, indicating slightly better performance.

Naive Bayes holdout candidate

pred_nb.h_highest_probs <- apply(nb.h_a_test_prob$posterior, 1, "max") 
pred_nb.h_correct <- nb.h_a_test_prob$class == holdout_age_groups.testing$age_group

pred_nb.h <- prediction(pred_nb.h_highest_probs, pred_nb.h_correct)

## precision/recall curve (x-axis: recall, y-axis: precision)
pr_nb.h <- performance(pred_nb.h, "prec", "rec")
plot(pr_nb.h)

This graph is interesting as it suggests an initially good rate of success which literally tails off.

Naive Bayes repeat k-folds cross-validation candidate

pred_nb.r5kf8_highest_probs <- apply(nb.r5kf8_a_test_prob, 1, "max") 
pred_nb.r5kf8_correct <- nb.r5kf8_a_test == holdout_age_groups.testing$age_group

pred_nb.r5kf8 <- prediction(pred_nb.r5kf8_highest_probs, pred_nb.r5kf8_correct)

## precision/recall curve (x-axis: recall, y-axis: precision)
pr_nb.r5kf8 <- performance(pred_nb.r5kf8, "prec", "rec")
plot(pr_nb.r5kf8)

When comparing this line to the line of the previous graph, it’s possible to see how cross validation manages to improve the line, increasing the area below the line ever so slightly.

KNN candidates

pred_knn.h_highest_probs <- apply(knn.h_a_test_prob, 1, "max") 
pred_knn.h_correct <- knn.h_a_test == holdout_age_groups.testing$age_group

pred_knn.h <- prediction(pred_knn.h_highest_probs, pred_knn.h_correct)

## precision/recall curve (x-axis: recall, y-axis: precision)
pr_knn.h <- performance(pred_knn.h, "prec", "rec")
plot(pr_knn.h)

pred_knn.r5kf8_highest_probs <- apply(knn.r5kf8_a_test_prob, 1, "max") 
pred_knn.r5kf8_correct <- knn.r5kf8_a_test == holdout_age_groups.testing$age_group

pred_knn.r5kf8 <- prediction(pred_knn.r5kf8_highest_probs, pred_knn.r5kf8_correct)

## precision/recall curve (x-axis: recall, y-axis: precision)
pr_knn.r5kf8 <- performance(pred_knn.r5kf8, "prec", "rec")
plot(pr_knn.r5kf8)

C4.5 Decision Tree candidate

acc_dt.c4_5 <- performance(pred_dt.c4_5, "acc")
plot(acc_dt.c4_5)

Random Forest Decision Tree k-folds candidate (overfit)

acc_dt.rf <- performance(pred_dt.rf, "acc")
plot(acc_dt.rf)

Random Forest Decision Tree holdout candidate

acc_dt.hrf2_h <- performance(pred_dt.hrf2_h, "acc")
plot(acc_dt.hrf2_h)

Naive Bayes holdout candidate

acc_nb.h <- performance(pred_nb.h, "acc")
plot(acc_nb.h)

Naive Bayes repeated k-folds cross-validation candidate

acc_nb.r5kf8 <- performance(pred_nb.r5kf8, "acc")
plot(acc_nb.r5kf8)

###KNN holdout candidate

acc_knn.h <- performance(pred_knn.h, "acc")
plot(acc_knn.h)

KNN repeated k-folds cross-validation candidate

acc_knn.r5kf8 <- performance(pred_knn.r5kf8, "acc")
plot(acc_knn.r5kf8)

C4.5 Decision Tree candidate

roc_dt.c4_5 = performance(pred_dt.c4_5, measure="tpr", x.measure="fpr")
plot(roc_dt.c4_5, col="orange", lwd=2) 
lines(x=c(0, 1), y=c(0, 1), col="red", lwd=2)

This doesn’t seem to be a particularly good result, though it is somewhat better than a 50:50 chance of correct classification, with peak performance easily identifiable; the model has the best rate of performance around the middle of the line where there is the best balance between the TPR and the coefficient with FPR, with TPR at over 0.6 and about 50% better than the FPR. After the peak point, the graph suggests accuracy goes down.

Random Forest Decision Tree k-folds candidate (overfit)

roc_dt.rf = performance(pred_dt.rf, measure="tpr", x.measure="fpr")
plot(roc_dt.rf, col="orange", lwd=2) 
lines(x=c(0, 1), y=c(0, 1), col="red", lwd=2)

This graph is a near perfect example, which has been included to demonstrate overfitting; this was because the test data was used as part of the training data. The yellow line draws a blocky, rectangular shape indicated a high rate of successful classification; if this was not the result of overfitting it would be an excellent result.

Random Forest Decision Tree holdout candidate

roc_dt.hrf2_h = performance(pred_dt.hrf2_h, measure="tpr", x.measure="fpr")
plot(roc_dt.hrf2_h, col="orange", lwd=2) 
lines(x=c(0, 1), y=c(0, 1), col="red", lwd=2)

This is a far more conservative result but it is at least, markedly better than the C4.5 decision tree. What’s worth doing is comparing this result to the Naive Bayes graphs below, which happen to have similar looking lines.

Naive Bayes holdout candidate

roc_nb.h = performance(pred_nb.h, measure="tpr", x.measure="fpr")
plot(roc_nb.h, col="orange", lwd=2) 
lines(x=c(0, 1), y=c(0, 1), col="red", lwd=2)

Naive Bayes repeated k-folds cross-validation candidate

roc_nb.r5kf8 = performance(pred_nb.r5kf8, measure="tpr", x.measure="fpr")
plot(roc_nb.r5kf8, col="orange", lwd=2) 
lines(x=c(0, 1), y=c(0, 1), col="red", lwd=2)

KNN holdout candidate

roc_knn.h = performance(pred_knn.h, measure="tpr", x.measure="fpr")
plot(roc_knn.h, col="orange", lwd=2) 
lines(x=c(0, 1), y=c(0, 1), col="red", lwd=2)

KNN repeated k-folds cross-validation candidate

roc_knn.r5kf8 = performance(pred_knn.r5kf8, measure="tpr", x.measure="fpr")
plot(roc_knn.r5kf8, col="orange", lwd=2) 
lines(x=c(0, 1), y=c(0, 1), col="red", lwd=2)

C4.5 Decision Tree candidate

auc_dt.c4_5 = performance(pred_dt.c4_5, "auc")
print(paste(c(auc_dt.c4_5@y.name, auc_dt.c4_5@y.values)), quote=FALSE)

## [1] Area under the ROC curve 0.608080500151196

Random Forest Decision Tree k-folds candidate (overfit)

auc_dt.rf = performance(pred_dt.rf, "auc")
print(paste(c(auc_dt.rf@y.name, auc_dt.rf@y.values)), quote=FALSE)

## [1] Area under the ROC curve 0.965840011052777

Random Forest Decision Tree holdout candidate

auc_dt.hrf2_h = performance(pred_dt.hrf2_h, "auc")
print(paste(c(auc_dt.hrf2_h@y.name, auc_dt.hrf2_h@y.values)), quote=FALSE)

## [1] Area under the ROC curve 0.698969506922962

Naive Bayes holdout candidate

auc_nb.h = performance(pred_nb.h, "auc")
print(paste(c(auc_nb.h@y.name, auc_nb.h@y.values)), quote=FALSE)

## [1] Area under the ROC curve 0.694184643497304

Naive Bayes repeated k-folds cross-validation candidate

auc_nb.r5kf8 = performance(pred_nb.r5kf8, "auc")
print(paste(c(auc_nb.r5kf8@y.name, auc_nb.r5kf8@y.values)), quote=FALSE)

## [1] Area under the ROC curve 0.694908696817499

KNN holdout candidate

auc_knn.h = performance(pred_knn.h, "auc")
print(paste(c(auc_knn.h@y.name, auc_knn.h@y.values)), quote=FALSE)

## [1] Area under the ROC curve 0.672607793022195

KNN repeated k-folds cross-validation candidate

auc_knn.r5kf8 = performance(pred_knn.r5kf8, "auc")
print(paste(c(auc_knn.r5kf8@y.name, auc_knn.r5kf8@y.values)), quote=FALSE)

## [1] Area under the ROC curve 0.732314474153576